perm filename PARSE.SAI[PNT,HE]1 blob
sn#367361 filedate 1978-07-10 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00006 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 ENTRY
C00004 00003 PROCEDURE ERRM1
C00009 00004 ! parse: number,nums,GTOKEN,namefile
C00020 00005 INTERNAL SIMPLE PROCEDURE SEMICOL_READ
C00026 00006 ! input from different sources
C00031 ENDMK
C⊗;
ENTRY;
BEGIN "PARSER"
DEFINE $PARSER = TRUE ;
REQUIRE "HEADER.SAI" SOURCE_FILE;
ifc TRUE thenc
RCLASS DEVSTACK(INTEGER DEV,DSKCHN; STRING $CLNE,$CLINR; RPTR(DEVSTACK)NEXT);
RPTR(DEVSTACK) DEVSTACKTOP;
PROCEDURE POPDEVSTACK;
BEGIN
IF DEVSTACKTOP=NULL_RECORD THEN ERROR("cant pop device stack, already at bottom");
IF DEVICE=DSK_X THEN RELEASE($INPCH);
DEVICE←DEVSTACK:DEV[DEVSTACKTOP];
IF DEVICE=DSK_X THEN BEGIN $INPCH←DEVSTACK:DSKCHN[DEVSTACKTOP]; $EOF←FALSE; END;
$CLNE←DEVSTACK:$CLNE[DEVSTACKTOP];
$CLINR←DEVSTACK:$CLINR[DEVSTACKTOP];
DEVSTACKTOP←DEVSTACK:NEXT[DEVSTACKTOP];
END;
INTERNAL PROCEDURE PUSHDEVSTACK;
BEGIN
RPTR(DEVSTACK) D1;
D1←NEW_RECORD(DEVSTACK);
IF (DEVSTACK:DEV[D1]←DEVICE)=DSK_X THEN
BEGIN DEVSTACK:DSKCHN[D1]←$INPCH;
$INPCH← - 1; END;
DEVSTACK:$CLNE[D1]←$CLNE;
DEVSTACK:$CLINR[D1]←$CLINR;
$CLNE←$CLINR←NULL;
DEVSTACK:NEXT[D1]←DEVSTACKTOP;
DEVSTACKTOP←D1;
END;
endc
PROCEDURE ERRM1;
BEGIN
ERROR("error in macro espansion:
PARAMETERS HAVE NOT PREVIOUSLY DEFINED FOR THIS MACRO");
END;
PROCEDURE ERRM2;
BEGIN
ERROR("error in macro espansion: ( OMITTED");
END;
PROCEDURE ERRM3;
BEGIN
ERROR("error in macro espansion: MISMATCHED NUMBERS OF PARAMETERS");
END;
PROCEDURE ERRM4;
BEGIN
ERROR("error in macro espansion: ⊃ OR ⊂ MISMATCHED ");
END;
PROCEDURE ERRM5;
BEGIN
ERROR("error in macro espansion: , OMITTED");
END;
PROCEDURE ERRM6;
BEGIN
ERROR("error in macro expansion: ) MISMATCHED ");
END;
PROCEDURE ERRM7;
BEGIN
ERROR("error in macro expansion: , SUPERFLOUS");
END;
INTEGER SPACE;
PROCEDURE BTINIT;
SETBREAK(SPACE←GETBREAK," ",NULL,"IA");
REQUIRE BTINIT INITIALIZATION;
STRING PROCEDURE EXPANDPROC(STRING S);
BEGIN
RCLASS PLIS(STRING PARVAL;RPTR(PLIS)NEXTV);
RPTR(PLIS) PLST, TEMPLT;
RPTR(SYMBOL) TEMPSY;
RPTR(MACRO) MOT;
RPTR(PLIST) TEMPLS;
STRING PREAD,VREAD,RESULT,CRBODY,SS,TEMPSS,VSREAD;
INTEGER BRCHAR,NP123,DLCOUNT;
NOEXPAND ← TRUE;
DLCOUNT ← 0;
TEMPSY ← CHECK(S, #MC);
IF TEMPSY = NULL_RECORD
THEN ERRM1;
MOT ← SYMBOL:OBJECT[TEMPSY];
IF MACRO:NPARAM[MOT] ≠ 0
THEN BEGIN
GTOKEN;
IF TOKEN NEQ "("
THEN ERRM2;
GTOKEN;
NP123 ← 0;
PLST ← NULL_RECORD;
WHILE TRUE
DO BEGIN
RPTR(PLIS) TEMP;
NP123 ← NP123+1;
TEMP←NEW!RECORD(PLIS);
PLIS:NEXTV[TEMP] ← PLST;
IF EQU(TOKEN,"⊃")
THEN ERRM4;
IF EQU(TOKEN,"⊂")
THEN BEGIN
DLCOUNT ← 1;
GTOKEN;
IF TOKEN = "⊂"
THEN DLCOUNT ← DLCOUNT + 1;
IF TOKEN = "⊃"
THEN DLCOUNT ← DLCOUNT - 1;
WHILE DLCOUNT ≠ 0
DO BEGIN
PLIS:PARVAL[TEMP]
← PLIS:PARVAL[TEMP]&TOKEN&'40;
GTOKEN;
IF TOKEN = "⊂"
THEN DLCOUNT ← DLCOUNT + 1;
IF TOKEN = "⊃"
THEN DLCOUNT ← DLCOUNT - 1;
END;
END
ELSE PLIS:PARVAL[TEMP] ← TOKEN & '40;
PLST ← TEMP;
GTOKEN;
IF EQU(TOKEN,")")
THEN DONE;
IF TOKEN NEQ ","
THEN ERRM5
ELSE GTOKEN;
IF EQU(TOKEN,",") OR EQU(TOKEN,")")
THEN ERRM7;
IF EQU(TOKEN,"=")
THEN ERRM6;
END;
IF MACRO:NPARAM[MOT] ≠ NP123
THEN ERRM3;
CRBODY ← NULL;
TEMPSS ← MACRO:BODY[MOT];
DO BEGIN
RESULT ← SCAN(TEMPSS,SPACE,BRCHAR);
TEMPLS ← MACRO:PARLST[MOT];
TEMPLT ← PLST;
WHILE TEMPLS ≠ NULL_RECORD
DO BEGIN
PREAD ← PLIST:PARAM[TEMPLS];
TEMPLS ← PLIST:NEXTP[TEMPLS];
VREAD ← PLIS:PARVAL[TEMPLT];
TEMPLT ← PLIS:NEXTV[TEMPLT];
IF EQU(RESULT,PREAD & '40)
THEN BEGIN
RESULT ← VREAD;
DONE;
END;
END;
CRBODY ← CRBODY & RESULT;
END
UNTIL EQU(TEMPSS, NULL);
SS ← CRBODY;
END
ELSE SS ← MACRO:BODY[MOT];
NOEXPAND ← FALSE;
RETURN(SS);
END;
! parse: number,nums,GTOKEN,namefile ;
! checks if num is a number or @;
SIMPLE BOOLEAN PROCEDURE NUMBER(INTEGER NUM);
RETURN( "0"≤NUM≤"9" OR NUM="@");
! checks if the string word contains only numbers;
SIMPLE BOOLEAN PROCEDURE NUMS(STRING WORD);
BEGIN "NS"
STRING WW; INTEGER BR;
WW←SCAN(WORD,$NUMTAB,BR);
IF BR=0 THEN RETURN (TRUE) ELSE RETURN (FALSE);
END "NS";
! returns true if the last TOKEN is a terminal character, CR or ;
INTERNAL SIMPLE BOOLEAN PROCEDURE FINAL;
RETURN(TOKEN=SEMC OR TOKEN=CR OR TOKEN=NULL);
! IF TOKEN=SEMC OR TOKEN=CR OR TOKEN=NULL OR $CLINR=NULL
THEN RETURN(TRUE)
ELSE RETURN(FALSE);
INTERNAL PROCEDURE READTO(STRING CHAR);
BEGIN INTEGER I,BRCHAR; STRING R;
SETBREAK(I←GETBREAK, CHAR, NULL, "IA");
R←SCAN($CLINR,I,BRCHAR);
WHILE BRCHAR≠CHAR DO BEGIN NEWLINE; R←SCAN($CLINR,I,BRCHAR); END;
RELBREAK(I);
END;
INTERNAL RECURSIVE PROCEDURE GTOKEN (BOOLEAN MUSTGETTOKEN(TRUE));
BEGIN "GTOKEN"
STRING WORD,WORD2;
INTEGER BRPARS; LABEL AGAIN; BOOLEAN NONSTOP;
! reads next RTOKEN using the indicated breaktable;
REQUIRE "<><>" DELIMITERS;
define rtoken(aaa)=<scan($CLINR, aaa ,brpars)>;
IF STOKEN THEN BEGIN STOKEN←FALSE;RETURN;END;
NONSTOP←MUSTGETTOKEN OR (DEVICE=DSK_X);
AGAIN: IF NONSTOP THEN WHILE $CLINR=NULL DO NEWLINE; WORD←NULL;#TOKEN ←UNDECLARED_TYPE;
RTOKEN($SPCTAB); ! skips blanks;
WORD←WORD&RTOKEN($RETAB); ! reads first RTOKEN;
IF WORD=NULL
THEN IF BRPARS="."
THEN BEGIN ! no object read, period found;
RTOKEN($SKTAB);
RTOKEN($ALFTAB); ! reads one character;
IF NUMBER(BRPARS)
THEN BEGIN
WORD←"."&RTOKEN($NUMTAB); ! reads until finds numbers;
#TOKEN ←REAL_TYPE; ! floating number read;
END
ELSE BEGIN
WORD←".";
#TOKEN ←OPERATOR_TYPE; ! period is only a punctuation mark;
END;
END
ELSE IF (BRPARS=CR or BRPARS=NULL) AND NONSTOP
THEN BEGIN
! a new line is required and then the RTOKEN is read;
NEWLINE;
GO TO AGAIN;
END
ELSE IF BRPARS="{"
THEN BEGIN
READTO("}");
GO TO AGAIN;
END
ELSE IF BRPARS="⊗"
THEN BEGIN
WORD←OLDOBJ;
RTOKEN($SKTAB);
#TOKEN←ID_TYPE;
END
ELSE BEGIN
WORD←BRPARS;
RTOKEN($SKTAB);
#TOKEN ←OPERATOR_TYPE; ! punctuation mark found;
END
ELSE IF BRPARS="."
THEN IF NUMS(WORD)
THEN BEGIN
WORD←WORD&".";
RTOKEN($SKTAB);
RTOKEN($ALFTAB); ! reads one character;
IF NUMBER(BRPARS)
THEN BEGIN ! there are more numbers;
WORD←WORD&RTOKEN($NUMTAB);
#TOKEN ←REAL_TYPE; ! floating number read;
END
ELSE BEGIN
#TOKEN ←REAL_TYPE; ! floating number read;
END;
END;
TOKEN←WORD;
! checks if RTOKEN is an integer number;
IF TOKEN
THEN
IF #TOKEN =UNDECLARED_TYPE
THEN BEGIN
WORD2←SCAN(WORD,$ALFTAB,BRPARS); ! reads one character;
IF NUMBER(BRPARS)
THEN BEGIN ! if first ch. is a number;
WORD2←SCAN(WORD,$NUMTAB,BRPARS);
IF BRPARS=0
THEN BEGIN ! only numbers found;
#TOKEN ←INT_TYPE; ! integer number read;
TOKEN←WORD2;
END
ELSE BEGIN
TOKEN←NULL; ! incorrect TOKEN;
ERROR ($SYNMSG[31],NULL);
END
END;
END;
IF #TOKEN=UNDECLARED_TYPE
THEN
IF DECSTR(TOKEN)≠0
THEN #TOKEN←RES_TYPE
ELSE begin
RECORD_POINTER(TREE)T1;
IF (TOKENINDEX←TREE:DTYPE[T1←DCDSYM(TOKEN)])
THEN BEGIN #TOKEN←ID_TYPE;
IF TOKENINDEX=#MC AND ¬NOEXPAND THEN
BEGIN STRING SSS;
SSS←EXPANDPROC(TOKEN);
$CLINR←SSS&$CLINR;
GTOKEN;
END
ELSE TOKENPTR←TREE:DATA[T1]; END;
end;
! IF TOKEN=NULL THEN GO TO AGAIN;
END "GTOKEN";
! reads a file name and returns it ;
INTERNAL STRING PROCEDURE NAMEFILE;
BEGIN "NAMEFILE"
STRING NAME;
GTOKEN;
IF #TOKEN =UNDECLARED_TYPE
THEN BEGIN "FILE"
NAME←TOKEN; ! name of file;
GTOKEN(FALSE);
IF #TOKEN =REAL_TYPE
THEN BEGIN "NUM" ! if extension is a number;
STRING P; P←LOP(TOKEN);
IF P="."
THEN BEGIN
NAME←NAME&"."&TOKEN;
GTOKEN(FALSE);
END
ELSE ERROR($SYNMSG[21],$SYNMSG[25]);
END "NUM"
ELSE IF EQU(TOKEN,".")
THEN BEGIN "EXT" ! extension;
GTOKEN;
IF #TOKEN =UNDECLARED_TYPE
THEN BEGIN
NAME←NAME&"."&TOKEN;
GTOKEN(FALSE);
END
ELSE ERROR($SYNMSG[21],$SYNMSG[25]);
END "EXT";
END "FILE"
ELSE ERROR($SYNMSG[23],$SYNMSG[25]);
IF TOKEN="["
THEN BEGIN "PPN" ! there is ppn;
GTOKEN;
IF #TOKEN =UNDECLARED_TYPE OR #TOKEN =INT_TYPE
THEN BEGIN "PR"
NAME←NAME&"["&TOKEN;
GTOKEN;
IF TOKEN=","
THEN BEGIN "PN"
GTOKEN; ! there is pn;
IF #TOKEN =UNDECLARED_TYPE
THEN BEGIN "PAREN"
NAME←NAME&","&TOKEN;
GTOKEN;
IF TOKEN="]"
THEN NAME←NAME&"]"
ELSE ERROR($SYNMSG[4],$SYNMSG[25]);
END "PAREN"
ELSE ERROR($SYNMSG[21],$SYNMSG[25]);
END "PN"
ELSE ERROR($SYNMSG[1],$SYNMSG[25]);
END "PR"
ELSE BEGIN
PRINT("--→ integer number ",$SYNMSG[25],"OR ");
ERROR($SYNMSG[21],$SYNMSG[25]);
END
END "PPN"
ELSE STOKEN←TRUE; ! was $tail←token&$tail;
RETURN(NAME);
END "NAMEFILE";
INTERNAL SIMPLE PROCEDURE SEMICOL_READ;
BEGIN
GTOKEN(FALSE);
IF NOT FINAL THEN ERROR($SYNMSG[0],$SYNMSG[25]);
END;
INTERNAL SIMPLE PROCEDURE RPAR_READ;
BEGIN
GTOKEN;
IF TOKEN≠")" THEN ERROR($SYNMSG[6],$SYNMSG[25]);
END;
INTERNAL SIMPLE PROCEDURE LPAR_READ;
BEGIN
GTOKEN;
IF TOKEN≠"(" THEN ERROR($SYNMSG[5],$SYNMSG[25]);
END;
INTERNAL SIMPLE STRING PROCEDURE IDF_READ;
BEGIN
GTOKEN;
IF #TOKEN =INT_TYPE OR #TOKEN=REAL_TYPE OR #TOKEN=OPERATOR_TYPE
THEN ERROR($SYNMSG[21],$SYNMSG[25])
ELSE RETURN(TOKEN);
END;
INTERNAL SIMPLE STRING PROCEDURE MVFR_READ;
BEGIN
GTOKEN;
IF EQU(TOKEN,"BY")
THEN BEGIN
STOKEN←TRUE;
RETURN("BARM");
END
ELSE IF #TOKEN=ID_TYPE THEN RETURN(TOKEN)
ELSE ERROR($SYNMSG[21],$SYNMSG[25]);
END;
INTERNAL SIMPLE PROCEDURE BY_READ;
BEGIN
GTOKEN;
IF NOT EQU(TOKEN,"BY")THEN ERROR($SYNMSG[10],$SYNMSG[25]);
END;
INTERNAL SIMPLE PROCEDURE TO_READ;
BEGIN
GTOKEN;
IF NOT EQU(TOKEN,"TO") THEN ERROR($SYNMSG[14],$SYNMSG[25]);
END;
INTERNAL SIMPLE PROCEDURE INTO_READ;
BEGIN
GTOKEN;
IF NOT EQU(TOKEN,"INTO") THEN ERROR($SYNMSG[11],$SYNMSG[25]);
END;
INTERNAL SIMPLE STRING PROCEDURE HAND_READ;
BEGIN ! reads BHAND or YHAND (default= BHAND);
GTOKEN;
IF EQU(TOKEN,"BHAND") OR EQU(TOKEN,"YHAND")
THEN RETURN(TOKEN)
ELSE IF EQU(TOKEN,"TO") OR EQU(TOKEN,"BY")
THEN BEGIN
STOKEN←TRUE;
RETURN("BHAND");
END
ELSE ERROR($SYNMSG[19],$SYNMSG[25]);
END;
INTERNAL SIMPLE STRING PROCEDURE ARM_READ;
BEGIN ! reads "BARM" or "YARM" (default=BARM);
GTOKEN(FALSE);
IF EQU(TOKEN,"YARM") OR EQU(TOKEN,"BARM")
THEN BEGIN
STRING WHAT;
WHAT←TOKEN;
SEMICOL_READ;
RETURN(WHAT);
END
ELSE IF TOKEN=";" OR FINAL
THEN RETURN("BARM")
ELSE ERROR($SYNMSG[18],$SYNMSG[25]);
END;
INTERNAL SIMPLE STRING PROCEDURE DEV_READ;
BEGIN ! reads BARM/YARM/POINTER (default=POINTER);
GTOKEN(FALSE);
IF EQU(TOKEN,"POINTER") OR EQU(TOKEN,"BARM") OR EQU(TOKEN,"YARM")
THEN BEGIN
STRING POS;
POS←TOKEN;
SEMICOL_READ;
RETURN(POS);
END
ELSE IF FINAL OR TOKEN=";"
THEN RETURN("POINTER")
ELSE BEGIN
PRINT($SYNMSG[18],"OR POINTER ",$SYNMSG[25]," OR",CRLF);
ERROR($SYNMSG[0],$SYNMSG[25]);
END;
END;
INTERNAL SIMPLE STRING PROCEDURE AXIS_READ;
BEGIN ! reads XHAT/YHAT/ZHAT or X/Y/Z;
GTOKEN;
IF EQU(TOKEN,"XHAT") OR EQU(TOKEN,"YHAT") OR EQU(TOKEN,"ZHAT")
THEN RETURN(TOKEN)
ELSE IF EQU(TOKEN,"X") OR EQU(TOKEN,"Y") OR EQU(TOKEN,"Z")
THEN RETURN(TOKEN&"HAT")
ELSE ERROR($SYNMSG[17],$SYNMSG[25]);
END;
! returns the WRT frame;
INTERNAL SIMPLE STRING PROCEDURE WRTCODE;
BEGIN
STRING RELFR; ! reads "{WRT <frame_id> }" ;
GTOKEN(FALSE);
IF EQU(TOKEN,"WRT")
THEN BEGIN "C"
RELFR←IDF_READ;
SEMICOL_READ;
RETURN(RELFR);
END "C"
ELSE IF FINAL
THEN RETURN("STATION")
ELSE BEGIN "E"
PRINT($SYNMSG[0],$SYNMSG[25], " OR ");
ERROR($SYNMSG[16],$SYNMSG[25]);
END "E"
END;
! returns the FROM frame "{FROM <frame>}" or STATION;
INTERNAL SIMPLE STRING PROCEDURE FROMPART;
BEGIN
STRING ROOT;
GTOKEN(FALSE);
IF EQU(TOKEN,"FROM")
THEN BEGIN
ROOT←IDF_READ;
SEMICOL_READ;
RETURN(ROOT);
END
ELSE IF FINAL
THEN RETURN("STATION")
ELSE BEGIN
PRINT($SYNMSG[0],$SYNMSG[25]," OR ");
ERROR("--→ FROM ",$SYNMSG[25]);
END;
END;
! input from different sources ;
IFC FALSE THENC
STRING SAV$CLNE,SAV$CLINR;
INTERNAL PROCEDURE ASKUSER(STRING S(NULL));
BEGIN
SAV$CLNE←$CLNE;
SAV$CLINR←$CLINR;
DEVICE←QUERY_X;
IF S=NULL THEN $CLNE←$CLINR←INCHWL ELSE $CLNE←$CLINR←S;
END;
INTEGER TTYLINES;
INTERNAL PROCEDURE NEWLINE;
BEGIN
IF DEVICE= QUERY_X
THEN BEGIN
$CLNE←SAV$CLNE;
$CLINR←SAV$CLINR;
DEVICE←TTY_X;
END
ELSE
IF DEVICE= TTY_X
THEN BEGIN
IF STBEGIN THEN OUTSTR("* ") ELSE OUTSTR("***>>> ");
$CLNE←$CLINR←INCHWL;
IF $OUT THEN BEGIN CPRINT($TTYCH,$CLNE,CRLF);
IF TTYLINES≥6 THEN BEGIN UDATEFILE($TTYCH); TTYLINES←0; END
ELSE TTYLINES←TTYLINES+1;
END;
END
ELSE IF DEVICE = DSK_X
THEN BEGIN
INTEGER CHAR; CHAR←INCHRS; ! STOP IF ANYTHING TYPED ON TTY;
IF $EOF THEN
BEGIN $ALLOW←0; RELEASE($INPCH);
DEVICE←TTY_X; UPDATE;
END
ELSE BEGIN
IF CHAR < 0
THEN BEGIN
$CLNE←$CLINR←INPUT($INPCH,$CRTAB);
IF NEWFILE THEN
BEGIN IF $CLNE[1 TO 17] =
"COMMENT ⊗ VALID"
THEN $CLNE←INPUT($INPCH,$FFTAB);
$CLNE←$CLINR←INPUT($INPCH,$CRTAB);
NEWFILE←FALSE;
END;
IF FILEPRINT THEN PRINT(CRLF,$CLNE);
END
ELSE BEGIN
$CLNE←$CLINR←NULL;
DEVICE←TTY_X;
$ALLOW←0; RELEASE($INPCH); UPDATE;
END;
END;
END;
END;
ELSEC
INTERNAL PROCEDURE ASKUSER(STRING S(NULL));
BEGIN
PUSHDEVSTACK;
DEVICE←QUERY_X;
IF S=NULL THEN $CLNE←$CLINR←INCHWL ELSE $CLNE←$CLINR←S;
END;
INTEGER TTYLINES;
INTERNAL PROCEDURE NEWLINE;
BEGIN
IF DEVICE= QUERY_X
THEN BEGIN
POPDEVSTACK;
END
ELSE
IF DEVICE= TTY_X
THEN BEGIN
IF STBEGIN THEN OUTSTR("* ") ELSE OUTSTR("***>>> ");
$CLNE←$CLINR←INCHWL;
IF $OUT THEN BEGIN CPRINT($TTYCH,$CLNE,CRLF);
IF TTYLINES≥6 THEN BEGIN UDATEFILE($TTYCH); TTYLINES←0; END
ELSE TTYLINES←TTYLINES+1;
END;
END
ELSE IF DEVICE = DSK_X
THEN BEGIN
INTEGER CHAR; CHAR←INCHRS; ! STOP IF ANYTHING TYPED ON TTY;
IF $EOF THEN
BEGIN $ALLOW←0; RELEASE($INPCH);
POPDEVSTACK;
UPDATE;
END
ELSE BEGIN
IF CHAR < 0
THEN BEGIN
$CLNE←$CLINR←INPUT($INPCH,$CRTAB);
IF NEWFILE THEN
BEGIN IF $CLNE[1 TO 17] =
"COMMENT ⊗ VALID"
THEN $CLNE←INPUT($INPCH,$FFTAB);
$CLNE←$CLINR←INPUT($INPCH,$CRTAB);
NEWFILE←FALSE;
END;
IF FILEPRINT THEN PRINT(CRLF,$CLNE);
END
ELSE BEGIN
WHILE DEVSTACKTOP DO POPDEVSTACK;
$ALLOW←0; UPDATE;
END;
END;
END;
END;
ENDC
END "PARSER";